﻿open System
open System.Collections.Generic

let gridWidth = 4
let gridHeight = 4
let initialNumbers = [1 .. 16]
let empty = initialNumbers.[initialNumbers.Length-1]
let numbers = List.toArray initialNumbers

let rec inversion n list blank =
    match list with
    | [] -> 0
    | head::tail ->
    let result = if head = blank then 0 else (if n > head then 1 else 0)
    result + (inversion n tail blank)

let rec sumInversion list blank =
    match list with
    | [] -> 0
    | head::tail -> (if head = blank then 0 else inversion head tail blank) + (sumInversion tail blank)

let isSolvable array blank inversions =
    let i = Array.IndexOf(array, blank)
    let row = i / gridWidth
    let rowFromBottom = gridHeight - row
    ((gridWidth%2=1)&&(inversions%2=0))||((gridWidth%2=0)&&((rowFromBottom%2=1)&&(inversions%2=0))||((rowFromBottom%2=0)&&(inversions%2=1)))

let printInversions array blank = 
    let inversions = sumInversion (Array.toList array) blank
    let solvable = isSolvable array blank inversions
    let s = sprintf "inversions=%d\t%s" inversions (if solvable then "It's solvable." else "It's unsolvable.")
    printfn "%s" s

let swap (a : int array) i j = 
    let temp = a.[i]
    a.[i] <- a.[j]
    a.[j] <- temp

let toXY i = (i % gridWidth, i / gridWidth)
let toIndex (x, y) = y * gridWidth + x
let inGrid (x, y) = (x >= 0 && x < gridWidth && y >= 0 && y < gridHeight)
let addTuple (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)

let breadthFirstSearch (obstacles : int array) source destination : (int * int) list =
    let directions = [(-1, 0); (1, 0); (0, -1); (0, 1)]
    let steps = Array.create 16 -1
    let paths = Array.create 16 (-1, -1)
    let q = new Queue<_>()
    q.Enqueue source
    steps.[toIndex source] <- 0
    let mutable found = false
    while not found && q.Count > 0 do
        let (x, y) = q.Dequeue()
        if (x, y) = destination then
            found <- true
        else
            let enqueue (x1, y1) =
                if inGrid (x1, y1) && steps.[toIndex (x1, y1)] = -1 && obstacles.[toIndex (x1, y1)] = 0 then
                    q.Enqueue (x1, y1)
                    steps.[toIndex (x1, y1)] <- steps.[toIndex (x, y)] + 1
                    paths.[toIndex (x1, y1)] <- (x, y)
            let d = List.map (addTuple (x, y)) directions
            List.iter enqueue d
    let pathList = new List<int * int>()
    if found then
        let mutable (x, y) = destination
        while x <> -1 && y <> -1 do
            pathList.Add((x, y))
            let p = paths.[toIndex (x, y)]
            x <- fst p
            y <- snd p
        pathList.Reverse()
    Array.toList (pathList.ToArray())

let rec swapAlongPath path numbers =
    match path with
    | [] -> ()
    |  first::rest ->
        match rest with
        | [] -> ()
        | second::_ -> swap numbers (toIndex first) (toIndex second)
        swapAlongPath rest numbers

let rec setArrayAlongPath path (grid : int array) value =
    match path with
    | [] -> ()
    | head::tail ->
        grid.[toIndex head] <- value
        setArrayAlongPath tail grid value

let printArray array =
    let print i x = printf "%d%s" x (if (i + 1) % gridWidth = 0 then "\n" else "\t")
    Array.iteri print array
    printfn ""

let printList list =
    let print i x = printf "%d%s" x (if (i + 1) % gridWidth = 0 then "\n" else "\t")
    List.iteri print list
    printfn ""

let rec printPath path =
    match path with
    | [] -> printfn "\n"
    | (x, y)::tail ->
        printf "(%d, %d)\t" x y
        printPath tail

let grid : int array = Array.zeroCreate 16
//grid.[4] <- 1
//grid.[5] <- 1
//grid.[11] <- 1
printfn "The obstacles are"
printArray grid
let source = (0, 0)
let destination = (2, 2)
let path1 = breadthFirstSearch grid source destination

printfn "path 1"
printPath path1
printfn "The board is"
printArray numbers
swapAlongPath path1 numbers
printfn "The board after swap along path 1"
printArray numbers

let path2 = breadthFirstSearch grid destination source
printfn "path 2"
printPath path2
swapAlongPath path2 numbers
printfn "The board after swap along path 2"
printArray numbers

let rec swapByMovingBlank path (board : int array) (obstacles : int array) blank =
    match path with
    | [] -> ()
    | first::rest ->
        match rest with
        | [] -> ()
        | second::_ ->
            let obstacle = obstacles.[toIndex first]
            obstacles.[toIndex first] <- -1
            let blankPosition = toXY (Array.IndexOf(board, blank))
            let (x1, y1) = blankPosition
            let (x2, y2) = second
            if blankPosition = second then
                printfn "The blank %d is alread at (%d, %d)" blank x1 y1
            else
                printfn "Move the blank from (%d, %d) to (%d, %d)" x1 y1 x2 y2
                let pathForBlank = breadthFirstSearch obstacles blankPosition second
                printfn "path to move"
                printPath pathForBlank
                swapAlongPath pathForBlank board
                printfn "after moving the blank"
                printArray board
            if board.[toIndex second] = blank then
                swap board (toIndex first) (toIndex second)
            else
                printfn "Error! Cannot move the blank from (%d, %d) to (%d, %d)" x1 y1 x2 y2
            printfn "after moving the tile"
            printArray board
            obstacles.[toIndex first] <- obstacle
            swapByMovingBlank rest board obstacles blank

let printListInOneLine list =
    match list with
    | [] -> printfn "\n"
    | head::tail -> printfn "%d\t" head

let diffTuple (x1, y1) (x2, y2) = (abs(x1 - x2), abs(y1 - y2))
let printTuple (x, y) = printfn "(%d, %d)" x y

// put the last two tiles into the row or column
let arrangeLastTwoTiles (board : int array) (positions : (int * int) list) (arrangement : (int * int) list) (obstacles : int array) blank (originalNumbers : int list) =
    let blankSource = toXY (Array.IndexOf(board, blank))
    let blankDest = positions.[positions.Length - 2]
    if blankSource <> blankDest then
        let blankPath = breadthFirstSearch obstacles blankSource blankDest
        swapAlongPath blankPath board
    let arrangementPath = [blankDest; arrangement.[arrangement.Length - 2]; arrangement.[arrangement.Length - 1]]
    let checkNumbers = [blank; originalNumbers.[originalNumbers.Length - 2]; originalNumbers.[originalNumbers.Length - 1]]
    printfn "arrangement path"
    printPath arrangementPath
    printfn "check numbers"
    printListInOneLine checkNumbers
    if List.forall2 (fun path num -> board.[toIndex path] = num) arrangementPath checkNumbers then
        printfn "Arrange the tiles into a single row or column"
        swapAlongPath arrangementPath board
        swapAlongPath arrangementPath obstacles
        printfn "board after arrangement"
        printArray board
        printfn "obstacles after arrangement"
        printArray obstacles
    else
        printfn "Error! The numbers along the path are different from expected."

let solveOneRound (board : int array) (targetBoard : int list) (positions : (int * int) list) (arrangement : (int * int) list) (obstacles : int array) blank offset =
    printfn "solveOneRound\tthe target positions"
    printPath positions
    let check (board : int array) (targetBoard : int list) pos =
        let i = toIndex pos
        board.[i] = targetBoard.[i]
    let organized = List.forall (check board targetBoard) positions
    if organized then
        printfn "This round is already done"
        List.iteri (fun i xy -> obstacles.[toIndex xy] <- i + 1) positions
        printfn "update obstacles"
        printArray obstacles
    else
        printfn "the arrangement"
        printPath arrangement
        let originalNumbers = [for i in positions -> targetBoard.[toIndex i]]
        let solveOneTile i num dest =
            printf "i=%d\tnum=%d\tdest=" i num
            printTuple dest
            // if current tile is the second last one and the last tile is close to the current target position, move the last one away
            if i = originalNumbers.Length - 2 then
                let LastTileOfThisRound = originalNumbers.[originalNumbers.Length-1]
                let lastTilePos = toXY (Array.IndexOf(board, LastTileOfThisRound))
                // check if the last tile is close to the second last tile's target position
                let areLastTwoTilesDone = (toXY (Array.IndexOf(board, num)) = dest) && (lastTilePos = arrangement.[arrangement.Length-1])
                printfn "Last two tiles are %s" (if areLastTwoTilesDone then "done" else "not yet done")
                let (dx, dy) = diffTuple lastTilePos dest
                if not areLastTwoTilesDone && (dx <= 1 && dy <= 1) then
                    let (x1, y1) = lastTilePos
                    let (x2, y2) = addTuple dest offset
                    printfn "The last tile %d at (%d, %d) is close to the second last tile %d at (%d, %d)" LastTileOfThisRound x1 y1 num x2 y2
                    printfn "Move %d from (%d, %d) to (%d, %d)" LastTileOfThisRound x1 y1 x2 y2
                    let pathForLastOne = breadthFirstSearch obstacles lastTilePos (x2, y2)
                    printfn "path to move the last one"
                    printPath pathForLastOne
                    swapByMovingBlank pathForLastOne board obstacles blank
            let source = toXY (Array.IndexOf(board, num))
            if source = dest then
                printfn "The tile %d is already at (%d, %d). no moves required" num (fst source) (snd source)
            else
                let path = breadthFirstSearch obstacles source dest
                printfn "path to restore"
                printPath path
                printfn "board before"
                printArray board
                swapByMovingBlank path board obstacles blank
                printfn "board after"
                printArray board
                let (x, y) = toXY (Array.IndexOf(board, num))
                if (x, y) <> dest then printfn "Error! %d is  not at (%d, %d) after the moves" num x y
            obstacles.[toIndex dest] <- i + 1
            printfn "update obstacles"
            printArray obstacles
        List.iteri2 solveOneTile originalNumbers arrangement
        // If there are at least two numbers to move, put the last two tiles into the row or column
        if arrangement.Length >= 2 then
            arrangeLastTwoTiles board positions arrangement obstacles blank originalNumbers

let compareNumbers (list1 : int list) (list2 : int list) xy =
    let i = toIndex xy
    list1.[i] = list2.[i]

let isDone (list1 : int list) (list2 : int list) (positions : (int * int) list)=
    List.forall (compareNumbers list1 list2) positions

let rec circularShift list numbers blank c =
    printf "shift path"
    printPath list
    match list with
    | [] -> ()
    | first::rest ->
        match rest with
        | [] -> ()
        | second::_ ->
            swap numbers (toIndex first) (toIndex second)
            printfn "after shift"
            printArray numbers
        if not (isDone (Array.toList numbers) initialNumbers c) then
            circularShift rest numbers blank c

let rec circularShiftFromBlank list numbers blank c =
    match list with
    | [] -> ()
    |  head::tail ->
        if head = toXY (Array.IndexOf(numbers, blank)) then
            circularShift (head::tail) numbers blank c
        else
            circularShiftFromBlank tail numbers blank c

let solvePuzzle board targetBoard blank =
    let obstacles : int array = Array.zeroCreate 16
    let rowOffset = (1, 2)
    let columnOffset = (2, 1)
    printfn "================================================================"
    solveOneRound board targetBoard [(3, 0); (2, 0); (1, 0); (0, 0)] [(3, 0); (2, 0); (0, 0); (0, 1)] obstacles blank rowOffset
    printfn "after solving this round"
    printArray board
    printfn "================================================================"
    solveOneRound board targetBoard [(0,3);(0,2);(0,1)] [(0,3);(0,1);(1,1)] obstacles blank columnOffset
    printfn "after solving this round"
    printArray board
    printfn "================================================================"
    solveOneRound board targetBoard [(3,1);(2,1);(1,1)] [(3,1);(1,1);(1,2)] obstacles blank rowOffset
    printfn "after solving this round"
    printArray board
    printfn "================================================================"
    solveOneRound board targetBoard [(1,3);(1,2)] [(1,2);(2,2)] obstacles blank columnOffset
    printfn "after solving this round"
    printArray board
    printfn "================================================================"
    // After 12 shifts, the last 4 pieces at the bottom right corner will go back to the initial state.
    // If the 15 puzzle is solvable, the last 4 pieces will be at their right positions after at most 11 shifts.
    let c = [(2,2); (3,2); (3,3); (2,3)]
    let circle = c @ c @ c @ c
    let isFinished1 = isDone (Array.toList numbers) initialNumbers c
    if not isFinished1 then
        printfn "circular shift"
        circularShiftFromBlank circle numbers empty c
        printfn "result"
        printArray numbers
    isDone (Array.toList numbers) initialNumbers c

let inversions = sumInversion (Array.toList numbers) empty
let solvable = isSolvable numbers empty inversions
if solvable then
    let isFinished = solvePuzzle numbers initialNumbers empty
    let s = sprintf "The puzzle is solvable %s" (if isFinished then "and I solved it." else "but I cannot solve it.")
    printfn "%s" s
else
    printfn "The puzzle is unsolvable."
printInversions numbers empty
